unit WinShell;

interface

uses Windows, ShlObj, ActiveX, Types;

type
  ItemIDListArray = array of PItemIDList;

const
  HDropFormat: FORMATETC =
   (cfFormat: CF_HDROP; ptd: nil;
    dwAspect: DVASPECT_CONTENT; lindex: -1; tymed: TYMED_HGLOBAL);

function GetFolder (Handle: HWND; Path: WideString = ''): IShellFolder;
function GetItemIDLists (Handle: HWND; Folder: IShellFolder; Files: array of WideString): ItemIDListArray;
procedure FreeItemIDLists (ItemIDLists: ItemIDListArray);

{IDataObject}
function GetDataObjectFromFiles (Handle: HWND; Path: WideString; Files: array of WideString): IDataObject;
function GetFilesFromDataObject (dataObj: IDataObject): TWideStringDynArray;

{ContextMenu}
function GetContextMenu (Handle: HWND; Path: WideString; Files: array of WideString): IContextMenu;
function PopupContextMenu (Handle: HWND; CtxMenu: IContextMenu; Pt: TPoint): UINT;
procedure InvokeCommandWithContextMenu (Handle: HWND; CtxMenu: IContextMenu; Cmd: UINT; Path: WideString);

{DragDropContextMenu}
function PopupDragDropContextMenu (Handle: HWND; Path: WideString;
                                   dataObj: IDataObject; pt: TPoint; var dwEffect: Longint): HResult;

implementation

function GetFolder (Handle: HWND; Path: WideString = ''): IShellFolder;
  var
    Desktop: IShellFolder;
    ItemIDList: PITEMIDLIST;
    Eaten, Attr: ULONG;
  begin
    Result := nil;
    if Succeeded(SHGetDesktopFolder({OUT} Desktop)) then begin
      if Path <> '' then begin
        Desktop.ParseDisplayName({IN}  Handle, nil, PWideChar(Path),
                                 {OUT} Eaten, ItemIDList, Attr);
        Desktop.BindToObject({IN}  ItemIDList, nil, IShellFolder,
                             {OUT} Result);
        CoTaskMemFree(ItemIDList);
      end else
        Result := Desktop;
    end;
  end;

function GetItemIDLists (Handle: HWND; Folder: IShellFolder; Files: array of WideString): ItemIDListArray;
  var
    I, K: Integer;
    Eaten, Attr: ULONG;
    ItemIDList: PITEMIDLIST;
  begin
    SetLength(Result, Length(Files));
    for I := 0 to Length(Files) - 1 do
      if Succeeded(Folder.ParseDisplayName
           ({IN}  Handle, nil, PWideChar(Files[I]),
            {OUT} Eaten, ItemIDList, Attr)) then begin
          Result[I] := ItemIDList;
      end else
      begin
        //failed
        for K := 0 to I - 1 do begin
          CoTaskMemFree(Result[K]);
        end;
        Result := nil;
        Exit;
      end;
  end;

procedure FreeItemIDLists (ItemIDLists: ItemIDListArray);
  var I: Integer;
  begin
    for I := 0 to Length(ItemIDLists) - 1 do begin
      CoTaskMemFree(ItemIDLists[I]);
    end;
  end;

function GetDataObjectFromFiles (Handle: HWND; Path: WideString; Files: array of WideString): IDataObject;
  var
    //P: Pointer;
    //F: FORMATETC;
    //M: STGMEDIUM;
    //T,
    //Path: WideString;
    //I: Integer;
    Folder: IShellFolder;
    ItemIDLists: ItemIDListArray;
  begin
    Result := nil;
    ItemIDLists := nil;

    Folder := GetFolder(Handle, Path);
    if not Assigned(Folder) then Exit;

    ItemIDLists := GetItemIDLists(Handle, Folder, Files);
    if not Assigned(ItemIDLists) then Exit;

    Folder.GetUIObjectOf({IN}  0, Length(ItemIDLists), ItemIDLists[0], IDataObject, nil,
                         {OUT} Result);
    FreeItemIDLists(ItemIDLists);

    (*
    F.ptd      := nil;
    F.dwAspect := DVASPECT_CONTENT;
    F.lindex   := -1;
    F.tymed    := TYMED_HGLOBAL;

    M.tymed := TYMED_HGLOBAL;
    M.unkForRelease := nil;

    //Drop Effect
    if Effect <> 0 then
    begin
      F.cfFormat := RegisterClipboardFormatW(CFSTR_PREFERREDDROPEFFECT);

      M.hGlobal := GlobalAlloc(GMEM_MOVEABLE, SizeOf(DWORD));
      P := GlobalLock(M.hGlobal);
      DWORD(P^) := Effect;
      GlobalUnlock(M.hGlobal);

      Result.SetData(F, M, True);
    end;

    //Text
    if IncludeText then
    begin
      Path := IncludeTrailingPathDelimiter(Dir);
      T := '';
      for I := Low(Files) to High(Files) do
        T := T + Path + Files[I] + #9;

      T[Length(T)] := #0;

      F.cfFormat := CF_UNICODETEXT;

      M.hGlobal := GlobalAlloc(GMEM_MOVEABLE, Length(T) * SizeOf(WideChar));
      P := GlobalLock(M.hGlobal);
      Move(PWideChar(T)^, P^, Length(T) * SizeOf(WideChar));
      GlobalUnlock(M.hGlobal);

      Result.SetData(F, M, True);
    end
    *)
  end;

function GetFilesFromDataObject (dataObj: IDataObject): TWideStringDynArray;
  type
    TGetFileName = function (var P: PByte): WideString;
  function GetFileNameW (var P: PByte): WideString;
    begin
      Result := PWideChar(P);
      Inc(P, (Length(Result) + 1) * SizeOf(WideChar));
    end;
  function GetFileNameA (var P: PByte): WideString;
    var S: AnsiString;
    begin
      S := PAnsiChar(P);
      Inc(P, (Length(S) + 1) * SizeOf(AnsiChar));
      Result := S;
    end;
  var
    M: STGMEDIUM;
    P: PByte;
    Cnt: Integer;
    GetFileName: TGetFileName;
  begin
    if dataObj.GetData(HDropFormat, M) = S_OK then begin
      P := GlobalLock(M.hGlobal);
      try
        if PDROPFILES(P)^.fWide then
          GetFileName := @GetFileNameW
        else
          GetFileName := @GetFileNameA;
        Inc(P, PDROPFILES(P)^.pFiles);
        SetLength(Result, 4);
        Cnt := 0;
        while P^ <> 0 do begin
          if Cnt >= Length(Result) then
            SetLength(Result, Cnt * 2);
          Result[Cnt] := GetFileName(P);
          Inc(Cnt);
        end;
        SetLength(Result, Cnt);
      finally
        GlobalUnlock(M.hGlobal);
        ReleaseStgMedium(M);
      end;
    end;
  end;

(*
 * ContextMenu
 *)
function GetContextMenu (Handle: HWND; Path: WideString; Files: array of WideString): IContextMenu;
  var
    Folder: IShellFolder;
    ItemIDLists: ItemIDListArray;
  begin
    ItemIDLists := nil;
    Folder := GetFolder(Handle, Path);
    if not Assigned(Folder) then Exit;

    ItemIDLists := GetItemIDLists(Handle, Folder, Files);
    Folder.GetUIObjectOf({IN}  Handle, Length(ItemIDLists), ItemIDLists[0], IContextMenu, nil,
                         {OUT} Result);
    FreeItemIDLists(ItemIDLists);
  end;

function PopupContextMenu (Handle: HWND; CtxMenu: IContextMenu; Pt: TPoint): UINT;
  var
    Menu: HMENU;
  begin
    Menu := CreatePopupMenu;
    try
      CtxMenu.QueryContextMenu(Menu, 0, $1000, $7fff, CMF_EXPLORE);
      Result := UINT(TrackPopupMenu(Menu, TPM_RETURNCMD or TPM_RIGHTBUTTON,
                                    Pt.X, Pt.Y, 0, Handle, nil));
    finally
      DestroyMenu(Menu);
    end;
  end;

procedure InvokeCommandWithContextMenu (Handle: HWND; CtxMenu: IContextMenu; Cmd: UINT; Path: WideString);
  var
    CmdInfo: CMINVOKECOMMANDINFOEX;
    AnsiPath: AnsiString;
  begin
    if Cmd > 0 then
    begin
      AnsiPath := Path;

      FillChar(CmdInfo, SizeOf(CmdInfo), 0);
      CmdInfo.cbSize  := SizeOf(CmdInfo);
      CmdInfo.fMask   := CMIC_MASK_UNICODE;
      CmdInfo.HWnd    := Handle;
      CmdInfo.nShow   := SW_SHOWNORMAL;
      {Ansi}
      CmdInfo.lpVerb      := PChar(Cmd - $1000);
      CmdInfo.lpDirectory := PChar(AnsiPath);
      {Wide}
      CmdInfo.lpVerbW      := PWideChar(Cmd - $1000);
      CmdInfo.lpDirectoryW := PWideChar(Path);

      CtxMenu.InvokeCommand(PCMINVOKECOMMANDINFO(@CmdInfo)^);
    end
  end;

(*
 * DragDropContextMenu
 *)
function PopupDragDropContextMenu (Handle: HWND; Path: WideString;
                                   dataObj: IDataObject; pt: TPoint; var dwEffect: Longint): HResult;
  function GetDropTarget: IDropTarget;
    var
      Folder: IShellFolder;
      ItemIDLists: ItemIDListArray;
    begin
      Result := nil;
      ItemIDLists := nil;

      Folder := GetFolder(Handle);
      if not Assigned(Folder) then Exit;

      ItemIDLists := GetItemIDLists(Handle, Folder, [Path]);
      Folder.GetUIObjectOf({IN}  Handle, Length(ItemIDLists), ItemIDLists[0],
                                 IDropTarget, nil,
                           {OUT} Result);
      FreeItemIDLists(ItemIDLists);
    end;
  var
    FDropTarget: IDropTarget;
  begin
    SetForegroundWindow(Handle);

    FDropTarget := GetDropTarget;

    Result := FDropTarget.DragEnter(dataObj, MK_RBUTTON, pt, dwEffect);
    if Result <> S_OK then Exit;
    Result := FDropTarget.DragOver(MK_RBUTTON, pt, dwEffect);
    if Result <> S_OK then Exit;

    Writeln('drag context menu begin');
    dwEffect := DROPEFFECT_COPY or DROPEFFECT_MOVE or DROPEFFECT_LINK;
    Result := FDropTarget.Drop(dataObj, MK_RBUTTON, pt, dwEffect);
    Writeln('drag context menu end');
  end;

end.
